home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / attall / moon.bas < prev    next >
Encoding:
BASIC Source File  |  1995-05-09  |  10.1 KB  |  209 lines
  1. DefDbl A-Z
  2. Global CurM$
  3. Global MoonNum
  4. Global MoonSUb
  5.  
  6. Sub CalcMoonPhases (YearI%, MonthI%, DayI%, Offset As Integer)
  7. Static DayC(1 To 35)  As String
  8. 'The original program is in lib 7 of the astronomy forum
  9. '(GO ASTROFORUM) as MOONPH.BAS
  10. 100   '*************************************************************************
  11. 200   '*                        PHASES OF THE MOON                             *
  12. 300   '*                                                                       *
  13. 400   '*                   Programmer: Daniel P. Franco                        *
  14. 500   '*                                                                       *
  15. 600   '*                          VERSION 1.0.0                                *
  16. 700   '*                          March 8, 1987                                *
  17. 800   '*                           [73307,3471]                                *
  18. 900   '*                                                                       *
  19. 1000  '*  This program calculates the phase of the moon for a given YearP      *
  20. 1100  '*  and MonthP. The user inputs the YearP, the MonthP, and the number of *
  21. 1200  '*  consecutive MonthPs data are required for. Output includes Ephemeris *
  22. 1300  '*  Time of each phase beginning with the new moon.                      *
  23. 1400  '*                                                                       *
  24. 1500  '*************************************************************************
  25. 1600  '*************************************************************************
  26. 1700  '*                                                                       *
  27. 1800  '*                           INPUT SECTION                               *
  28. 1900  '*                                                                       *
  29. 2000  '*************************************************************************
  30. 'This routine seems to work.  We haven't a clue how, but...
  31. 'Praise Daniel!  Good stuff...
  32.  
  33.      For i% = 1 To 35
  34.      DayC(i%) = ""
  35.      Next i%
  36.      YearP = YearI%
  37.      MonthP = MonthI%
  38.      MonthP = MonthP - 1
  39.      If MonthP = 0 Then
  40.         MonthP = 12
  41.         YearP = YearP - 1
  42.      End If
  43. 2500 LEAP = YearP Mod 4    'if leap = 0 then YearP is a leap YearP
  44. 2900 COUNT = 3
  45.      'YD = 0
  46. 3000 If LEAP <> 0 Then 3400 Else 4700
  47. 3100 '**************************************************************************
  48. 3200 '*                 CALCULATION FOR DECIMAL YearPS                          *
  49. 3300 '**************************************************************************
  50.      
  51. 3400 If MonthP = 1 Then YD = 4.24375935815675E-02
  52. 3500 If MonthP = 2 Then YD = .123205916849712
  53. 3600 If MonthP = 3 Then YD = .203974240117857
  54. 3700 If MonthP = 4 Then YD = .287480472649328
  55. 3800 If MonthP = 5 Then YD = .3709867051808
  56. 3900 If MonthP = 6 Then YD = .454492937712271
  57. 4000 If MonthP = 7 Then YD = .537999170243743
  58. 4100 If MonthP = 8 Then YD = .622874357406878
  59. 4200 If MonthP = 9 Then YD = .706380589938349
  60. 4300 If MonthP = 10 Then YD = .789886822469821
  61. 4400 If MonthP = 11 Then YD = .873393055001292
  62. 4500 If MonthP = 12 Then YD = .956899287532764
  63. 4600 GoTo 6000
  64. 4700 If LEAP = 0 GoTo 4800
  65. 4800 If MonthP = 1 Then YD = 4.24375935815675E-02
  66. 4900 If MonthP = 2 Then YD = .124574871481376
  67. 5000 If MonthP = 3 Then YD = .20534319474952
  68. 5100 If MonthP = 4 Then YD = .288849427280992
  69. 5200 If MonthP = 5 Then YD = .372355659812463
  70. 5300 If MonthP = 6 Then YD = .455861892343935
  71. 5400 If MonthP = 7 Then YD = .539368124875406
  72. 5500 If MonthP = 8 Then YD = .624243312038541
  73. 5600 If MonthP = 9 Then YD = .707749544570013
  74. 5700 If MonthP = 10 Then YD = .791255777101484
  75. 5800 If MonthP = 11 Then YD = .874762009632956
  76. 5900 If MonthP = 12 Then YD = .958268242164428
  77. 6000 K = ((YearP + YD) - 1900) * 12.3685
  78. 6100 K = CInt(K)
  79. 6200 COUNT = K + COUNT
  80. 6300 T = K / 1236.85
  81. 6400 T2 = T ^ 2
  82. 6500 T3 = T ^ 3
  83. 6600 PI = 3.14159265358979
  84. 6700 R = PI / 180
  85. 6800 '**************************************************************************
  86. 6900 '*                        SUN MEAN ANOMALY                                *
  87. 7000 '**************************************************************************
  88. 7100 SMA = 359.2242 + (29.10535608 * K) - (.0000333 * T2) - (.00000347 * T3)
  89. 7200 If SMA > 360 Then SMA = SMA / 360: SMA = SMA - Fix(SMA): SMA = SMA * 360
  90. 7300 '**************************************************************************
  91. 7400 '*                       MOON MEAN ANOMALY                                *
  92. 7500 '**************************************************************************
  93. 7600 MMA = 306.0253 + (385.81691806 * K) + (.0107306 * T2) + (.00001236 * T3)
  94. 7700 If MMA > 360 Then MMA = MMA / 360: MMA = MMA - Fix(MMA): MMA = MMA * 360
  95. 7800 '**************************************************************************
  96. 7900 '*                 MOON'S ARGUMENT OF LATITUDE                            *
  97. 8000 '**************************************************************************
  98. 8100 F = 21.2964 + (390.67050646 * K) - (.0016528 * T2) - (.00000239 * T3)
  99. 8200 If F > 360 Then F = F / 360: F = F - Fix(F): F = F * 360
  100. 8300 '**************************************************************************
  101. 8400 '*                   MEAN PHASE OF THE MOON                               *
  102. 8500 '**************************************************************************
  103. 8600 JD = 2415020.75933 + (29.53058868 * K) + (.0001178 * T2) - (.000000155 * T3) + (.00033 * Sin((R * 166.56) + (R * 132.87) * T) - ((R * .009173 * T2)))
  104. 8700 SMA = SMA * R
  105. 8800 MMA = MMA * R
  106. 8900 F = F * R
  107. 9000 '**************************************************************************
  108. 9100 '*        TRUE PHASE CORRECTIONS FOR NEW AND FULL MOON                    *
  109. 9200 '**************************************************************************
  110. 9300 If K - Fix(K) = 0 Or K - Fix(K) = .5 Or K - Fix(K) = -.5 Then 9400 Else 11100
  111. 9400 JD = JD + ((.1734 - .000393 * T) * Sin(SMA))
  112. 9500 JD = JD + (.0021 * Sin(2 * SMA))
  113. 9600 JD = JD - (.4068 * Sin(MMA))
  114. 9700 JD = JD + (.0161 * Sin(2 * MMA))
  115. 9800 JD = JD - (.0004 * Sin(3 * MMA))
  116. 9900 JD = JD + (.0104 * Sin(2 * F))
  117. 10000 JD = JD - (.0051 * Sin(SMA + MMA))
  118. 10100 JD = JD - (.0074 * Sin(SMA - MMA))
  119. 10200 JD = JD + (.0004 * Sin((2 * F) + SMA))
  120. 10300 JD = JD - (.0004 * Sin((2 * F) - SMA))
  121. 10400 JD = JD - (.0006000001 * Sin((2 * F) + MMA))
  122. 10500 JD = JD + (.001 * Sin((2 * F) - MMA))
  123. 10600 JD = JD + .0005 * Sin(SMA + (2 * MMA))
  124. 10700 GoTo 14300
  125. 10800 '*************************************************************************
  126. 10900 '*        TRUE PHASE CORRECTIONS FOR FOR FIRST AND LAST QUARTER          *
  127. 11000 '*************************************************************************
  128. 11100 JD = JD + (.1721 - .0004 * T) * Sin(SMA)
  129. 11200 JD = JD + .0021 * Sin(2 * SMA)
  130. 11300 JD = JD - .628 * Sin(MMA)
  131. 11400 JD = JD + .0089 * Sin(2 * MMA)
  132. 11500 JD = JD - .0004 * Sin(3 * MMA)
  133. 11600 JD = JD + .0079 * Sin(2 * F)
  134. 11700 JD = JD - .0119 * Sin(SMA + MMA)
  135. 11800 JD = JD - .0047 * Sin(SMA - MMA)
  136. 11900 JD = JD + .0003 * Sin(2 * F + SMA)
  137. 12000 JD = JD - .0004 * Sin(2 * F - SMA)
  138. 12100 JD = JD - .0006000001 * Sin(2 * F + MMA)
  139. 12200 JD = JD + .0021 * Sin(2 * F - MMA)
  140. 12300 JD = JD + .0003 * Sin(SMA + 2 * MMA)
  141. 12400 JD = JD + .0004 * Sin(SMA - 2 * MMA)
  142. 12500 JD = JD - .0003 * Sin(2 * SMA - MMA)
  143. 12600 '*************************************************************************
  144. 12700 '*             ADDITIONAL FIRST QUARTER CORRECTION                       *
  145. 12800 '*************************************************************************
  146. 12900 If K >= 0 And K - Fix(K) = .25 Then 13100 Else 13000
  147. 13000 If K < 0 And K - Fix(K) = -.75 Then 13100 Else 13600
  148. 13100 JD = JD + .0028 - .0004 * Cos(SMA) + .0003 * Cos(MMA)
  149. 13200 GoTo 14300
  150. 13300 '*************************************************************************
  151. 13400 '*             ADDITIONAL LAST QUARTER CORRECTION                        *
  152. 13500 '*************************************************************************
  153. 13600 If K >= 0 And K - Fix(K) = .75 Then 13800 Else 13700
  154. 13700 If K < 0 And K - Fix(K) = -.25 Then 13800 Else 14300
  155. 13800 JD = JD - .0028 + .0004 * Cos(SMA) - .0003 * Cos(MMA)
  156. 13900 GoTo 14300
  157. 14000 '*************************************************************************
  158. 14100 '*                CALENDAR DATE CALCULATION                              *
  159. 14200 '*************************************************************************
  160. 14300 JD = JD + .5
  161. 14400 Z = Int(JD)
  162. 14500 FRAC = JD - Fix(JD)
  163. 14600 If Z < 2299161! Then A = Z
  164. 14700 If Z >= 2299161! Then ALPHA = Int((Z - 1867216.25) / 36524.25)
  165. 14800 If Z >= 2299161! Then A = Z + 1 + ALPHA - Int(ALPHA / 4)
  166. 14900 B = A + 1524
  167. 15000 C = Int((B - 122.1) / 365.25)
  168. 15100 D = Int(365.25 * C)
  169. 15200 E = Int((B - D) / 30.6001)
  170. 15300 DOM = B - D - Int(30.6001 * E) + FRAC
  171. 15400 If E < 13.5 Then M = E - 1
  172. 15500 If E > 13.5 Then M = E - 13
  173. 15600 If M > 2.5 Then Y = C - 4716
  174. 15700 If M < 2.5 Then Y = C - 4715
  175. 15800 DayInt = Int(DOM)
  176. 15900 DAYFRAC = DOM - Fix(DOM)
  177. 16000 TOTSEC = DAYFRAC * 86400!
  178. 16100 TOTHOURS = (TOTSEC / 60) / 60
  179. 16200 HourP = Int(TOTHOURS)
  180. 16300 MINLEFT = TOTHOURS - Fix(TOTHOURS)
  181. 16400 TOTMIN = (MINLEFT * 60)
  182. 16500 MIN = Int(TOTMIN)
  183. 16600 SECLEFT = TOTMIN - Fix(TOTMIN)
  184. 16700 SEC = (SECLEFT * 60)
  185.       PHASE$ = ""
  186. 16800 If K >= 0 And K - Fix(K) = 0 Then PHASE$ = "M3"
  187. 16900 If K >= 0 And K - Fix(K) = .25 Then PHASE$ = "M2"
  188. 17000 If K >= 0 And K - Fix(K) = .5 Then PHASE$ = "M1"
  189. 17100 If K >= 0 And K - Fix(K) = .75 Then PHASE$ = "M4"
  190. 17200 If K < 0 And K - Fix(K) = 0 Then PHASE$ = "M3"
  191. 17300 If K < 0 And K - Fix(K) = -.75 Then PHASE$ = "M2"
  192. 17400 If K < 0 And K - Fix(K) = -.5 Then PHASE$ = "M1"
  193. 17500 If K < 0 And K - Fix(K) = -.25 Then PHASE$ = "M4"
  194.       On Error Resume Next
  195.       If DateSerial(Y, M, DayInt) <= DateSerial(YearI%, MonthI%, DayI% + 1) And PHASE$ <> "" Then CurM$ = PHASE$
  196.       On Error GoTo 0
  197. 17600 'Print Y, M, DAYINT, HourP, "Hours", MIN, "Min.", SEC, "Sec.", PHASE$
  198. 17700 K = K + .25
  199. 17800 If K = COUNT GoTo 18000
  200. 17900 GoTo 6300
  201. 18000 '
  202. MoonNum = Val(Right$(CurM$, 1))
  203. If MoonNum = 1 Then MoonSUb = 5
  204. If MoonNum = 2 Then MoonSUb = 0
  205. If MoonNum = 3 Then MoonSUb = 15
  206. If MoonNum = 4 Then MoonSUb = 10
  207. End Sub
  208.  
  209.